; ORIGINAL: 3dt2.1/examples/pick.scm
; $Id: pick.scm,v 1.12 2000/02/17 20:08:07 jmb Exp $
;======================================================================
; Purpose---
;    Define procedures for picking and highlighting entities
;
;======================================================================

(provide 'pick)

;; Flash-Time is the time in milliseconds that flash will highlight entities
(define Flash-Time 200)
;; flash is used to highlight an entity or list of entities.

;; Test to see if an object is either an entity or an entray
(define (entity-or-entray? e) (or (entity? e) (entray? e)))

;; Test to see if an object is a list of entities
(define (entity-list? o)
  (if (and (list? o) (not (null? o)))
      (let loop ((l o))
        (cond
          ((null? l) #t)
          ((entity-or-entray? (car l)) (loop (cdr l)))
          (else #f)
          )
        )
      #f
      )
  )

;; Highlight and entity or list of entities for a short time
(define flash
  (lambda (e)
    (if (or (entity-or-entray? e) (entity-list? e))
        (begin
          (entity:set-highlight e #t)
          (system:sleep Flash-Time)
          (entity:set-highlight e #f)
          ))
    e))

;; Define some stuff to make picking easier

(define pick:vertex-or-point
  (lambda (evt . filt)
    (let ((ent (apply pick:vertex evt filt)))
      (if (vertex? ent)
          ent
          (let ((pfilt (apply filter:and (filter:type "point?") filt)))
            (pick:entity evt pfilt))))))

(define pick:entity-position
  (lambda (evt . filt)
    (let ((v (apply pick:vertex-or-point evt filt)))
      (cond
        ((vertex? v) (vertex:position v))
        ((point? v) (point:position v))
        (else #f)
        ))))

(define pick:entity-with-ray
  (lambda (evt . filt)
    (let ((r (pick:ray evt))
          (e (apply pick:entity evt filt))
          )
      (entray e r)
      )))

(define pick:edge-with-ray
  (lambda (r . filt)
    (let ((e (apply pick:edge r filt))
          )
      (entray e r)
      )))


(define (get-window) (let* ((p1 (read-event))
                            (p2 (begin
                                  (rbd:window #t p1)
                                  (read-event))))
                       (rbd:remove-type rbd:window?)
                       (cons p1 p2)))

(define (draw-circle center radius cur-view)
  (if cur-view
      (let* ((sides 20)
             ;; Define a vector to contain the vertex positions
             (points (make-vector (+ sides 1) (position 0 0 0)))
             ;; Compute transformation from one vertex to the next
             (normal (gvector:unitize (gvector:from-to (view:eye) (view:target))))
             (trans (transform:rotation center normal (/ 360 sides)))
             ; Start radius from the center
             (pos (position:offset center (gvector:scale (gvector:unitize (view:up)) radius))))
        (begin
          ;; Set the positions in a do loop
          (vector-set! points 0 (position:copy pos))
          (vector-set! points sides (position:copy pos))
          (do ((i 1 (+ i 1)))
              ((= i sides))
              (vector-set! points i
                           (position:transform (vector-ref points (- i 1))
                                               trans)
                           ))
          (view:draw-polyline points cur-view)))))

(define rb-ray-start-hook
  (lambda (self pe)
    (let* ((view (event:view pe))
           (pos (pick:position pe))
           (radius (option:get "raysize")))
      (begin
        ;(format #t "starting ~%")
        (view:set-rb-mode #t view)
        (draw-circle pos radius view)
        (view:set-rb-mode #f view)
        (rbd:scheme-set-local self 0 pos)
        (rbd:scheme-set-local self 1 radius)
        (rbd:scheme-set-local self 2 view)))))

(define rb-ray-adjust-raysize
  (lambda (pe old-radius old-pos new-pos)
    (if (event:shift? pe)
        (cond
          ((> (position:y new-pos) (position:y old-pos))
           (begin
             (option:set 'raysize (* old-radius 1.2))
             (option:get 'raysize)))
          ((< (position:y new-pos) (position:y old-pos))
           (begin
             (option:set 'raysize (* old-radius .8))
             (option:get 'raysize)))
          (else old-radius))
        old-radius)))

(define rb-ray-update-hook
  (lambda (self pe)
    (let* ((old-pos (rbd:scheme-get-local self 0))
           (old-radius (rbd:scheme-get-local self 1))
           (old-view (rbd:scheme-get-local self 2))
           (new-view (event:view pe))
           (new-pos (pick:position pe))
           (new-radius (rb-ray-adjust-raysize pe old-radius old-pos new-pos)))
      (begin
        ;(format #t "updating ~%")
        (view:set-rb-mode #t old-view)
        (draw-circle old-pos old-radius old-view)
        (view:set-rb-mode #f old-view)
        (view:set-rb-mode #t new-view)
        (draw-circle new-pos new-radius new-view)
        (view:set-rb-mode #f new-view)
        (rbd:scheme-set-local self 0 new-pos)
        (rbd:scheme-set-local self 1 new-radius)
        (rbd:scheme-set-local self 2 new-view)))))

(define rb-ray-stop-hook
  (lambda (self)
    (let* ((old-pos (rbd:scheme-get-local self 0))
           (old-radius (rbd:scheme-get-local self 1))
           (old-view (rbd:scheme-get-local self 2)))
      (begin
        ;(format #t "stopping ~%")
        (view:set-rb-mode #t old-view)
        (draw-circle old-pos old-radius old-view)
        (view:set-rb-mode #f old-view)))))

(define rb-ray-repaint-hook
  (lambda (self view)
    (let* ((old-pos (rbd:scheme-get-local self 0))
           (old-radius (rbd:scheme-get-local self 1))
           (old-view (rbd:scheme-get-local self 2)))
      (if (eqv? view old-view)
          (begin
            ;(format #t "repainting ~%")
            (view:set-rb-mode #t old-view)
            (draw-circle old-pos old-radius old-view)
            (view:set-rb-mode #f old-view))))))

(define rb-ray-hook-vector
  (vector                               ;Hooks
    ; 0 Init-Hook
    #f;(lambda (self))
    ; 1 Start-Hook
    rb-ray-start-hook           ; (lambda (self pe))
    ; 2 Update-Hook
    rb-ray-update-hook       ;(lambda (self pe))
    ; 3 Stop-Hook
    rb-ray-stop-hook          ;(lambda (self))
    ; 4 Repaint-Hook
    rb-ray-repaint-hook
    ; 5 Position-Hook
    #f;(lambda (self pe))
    ; 6 End-Hook
    #f;(lambda (self))
    ))

; A rubberbander to display the pick-ray as a circle and adjust it if  Shift is pressed
(define rb-ray
  (rbd:scheme #f
              rb-ray-hook-vector
              (make-vector 3)            ; Locals
              )
  )

(define rb-highlight-pick-update-hook
  (lambda (self pe)
    (let* ((pick-proc (rbd:scheme-get-local self 0))
           (filter (rbd:scheme-get-local self 1))
           (old-ent (rbd:scheme-get-local self 2))
           (new-ent (apply pick-proc (event:ray pe) filter)))
      (begin
        (rbd:scheme-set-local self 2 new-ent)
        (if (entity? new-ent)
            (if (not (eqv? old-ent new-ent))
                (begin
                  (format #t "Updating Highlight from ~a to ~a ~%" old-ent new-ent)
                  (entity:set-highlight new-ent #t)
                  (if (entity? old-ent) (entity:set-highlight old-ent #f))))
            (if (entity? old-ent) (entity:set-highlight old-ent #f)))))))

(define rb-highlight-pick-hook-vector
  (vector                               ;Hooks
    ; 0 Init-Hook
    #f;(lambda (self))
    ; 1 Start-Hook
    #f ; (lambda (self pe))
    ; 2 Update-Hook
    rb-highlight-pick-update-hook      ;(lambda (self pe))
    ; 3 Stop-Hook
    #f ;(lambda (self))
    ; 4 Repaint-Hook
    #f; (lambda (self view))
    ; 5 Position-Hook
    #f;(lambda (self pe))
    ; 6 End-Hook
    #f;(lambda (self))
    ))

; A rubberbander to highlight what would be picked if the left button pressed now
(define rb-highlight-pick
  (lambda (pick-proc filter)
    (rbd:scheme #f
                rb-highlight-pick-hook-vector
                (vector pick-proc filter #f)
                )
    )
  )

(define highlight-picks #f)

;; This procedure creates a procedure for interactively picking something
;; The procedure returned will take one optional argument which is a
;; pick filter
(define (make-pick-proc pick-proc)
  (lambda filter
    (begin
      (rbd:push rb-ray)
      (if highlight-picks (rbd:add (rb-highlight-pick pick-proc filter)))
      (let ((ent (let loop ((evt (read-ray)))
                   (if (ray:valid? evt)
                       (let ((ent (apply pick-proc evt filter)))
                         (cond
                           ((entity? ent) (flash ent)ent)
                           ((entray? ent) (flash (entray:entity ent)) ent)
                           (else
                             (system:bell)
                             (loop (read-ray))
                             )))
                       #f))))
        (begin
          (rbd:pop)
          ent)))))
  
(define pick (make-pick-proc pick:entity))
(define pick-edge (make-pick-proc pick:edge))
(define pick-vertex (make-pick-proc pick:vertex-or-point))
(define pickr (make-pick-proc pick:entity-with-ray))
(define pick-edger (make-pick-proc pick:edge-with-ray))
(define (pick-region . filter)
  (let ((w (get-window)))
    (flash (apply pick:in-region (car w) (cdr w) filter))))
  
(define (pick-face . args)
  (begin
    (rbd:push rb-ray)
    (if (null? args)
        (if highlight-picks (rbd:add (rb-highlight-pick pick:face '(1))))
        (if highlight-picks (rbd:add (rb-highlight-pick pick:face args))))
    (let* ((ent
             (if (null? args)
                 (flash (pick:face (read-ray) 1))
                 (flash (apply pick:face (read-ray) args))
                 )))
      (begin
        (rbd:pop)
        ent))))
  
(define (pick-loop) (let ((e1 (pick-edge))
                          (e2 (pick-edge))
                          )
                      (flash (loop:find e1 e2))))
  
(define (pick-cell . args)
  (if (or (null? args) (< (car args) 2))
      (flash (cell:find (pick:face (read-ray) 1)))
      (flash
        (let ((re (read-ray))) (cell:find (pick:face re (car args)) (pick:face re (- (car args) 1))))
        )
      ))
  
(define (pick-chain) (flash (edge:chain (pick-edge))))
  
  ;; Some shortcuts for getting positions
(define (~p)
  (let ((evt (read-ray)))
    (if (ray:valid? evt)
        (pick:position evt)
        #f)))
  
  ;; end point of curve
(define (~e) (let ((v (pick-vertex)))
               (cond
                 ((vertex? v) (vertex:position v))
                 ((point? v) (point:position v))
                 (else #f))))
  
  ;; mid point of curve
(define (~m)
  (let ((crv (pick-edge)))
    (if (edge? crv) (curve:eval-pos crv .5) #f)))
  
  ;; closest point on curve
(define (~c)
  (let ((eray (pick-edger)))
    (if (and (entray? eray) (edge? (entray:entity eray)))
        (car (curve:ray-pos eray))
        #f)))
  
  ;; Get a position using rectangle rubberbanding
(define ~rrp (lambda (p)
               (let ((pt))
                 (rbd:rectangle #t p)
                 (set! pt (~p))
                 (rbd:remove-type rbd:rectangle?)
                 pt)))
  
  ;; pick a list of ENTITYs
(define (general-pick-list pick-proc . filter)
  (let loop ((evt (read-event))
             (elist '()))
    (if (event:right? evt)
        (begin
          (entity:set-highlight elist #f)
          (reverse elist)
          )
        (let ((ent (apply pick-proc evt filter)))
          (if (entity-or-entray? ent)
              (begin
                (entity:set-highlight ent #t)
                (loop (read-event) (cons ent elist))
                )
              (begin
                (system:bell)
                (loop (read-event) elist)
                ))))))
  
(define (get-pick-list . filter)
  (apply general-pick-list pick:entity filter))
(define (get-edge-list . filter)
  (apply general-pick-list pick:edge filter))
(define (get-pickr-list . filter)
  (apply general-pick-list pick:edge-with-ray filter))
  
  ;; pick a list of positions
(define (get-pos-list)
  (let loop ((evt (read-event))
             (poslist '())
             )
    (if (event:left? evt)
        (loop (read-event) (cons (pick:position evt) poslist))
        (reverse poslist)
        )))
  
  ;; pick a coedge by first picking a face and then an associated edge
(define pick-a-face
  (lambda ()
    (display "Pick a face\n")
    (pick-face)))
  
(define pick-an-edge
  (lambda ()
    (display "Pick an edge\n")
    (pick-edge)))
  
(define find-in-entity-list
  (lambda (entity-list this-entity)
    (if (and (entity-list? entity-list) (> (length entity-list ) 0) (entity? this-entity))
        (let ((found #f))
          (do ((i (- (length entity-list) 1) (- i 1)))
              ((or (< i 0) found) found)
              (if (equal? (list-ref entity-list i) this-entity)
                  (set! found (list-ref entity-list i) ))))
        (display "Invalid parameters passed to find-in-entity-list\n"))))
  
(define match-entity
  (lambda (entity-list1 entity-list2)
    (if (and (entity-list? entity-list1) (> (length entity-list1 ) 0) (entity-list? entity-list2) (> (length entity-list2 ) 0) )
        (let ((found #f))
          (do ((i (- (length entity-list2) 1) (- i 1)))
              ((or (< i 0) found) found)
              (set! found (find-in-entity-list entity-list1 (list-ref entity-list2 i)))))
        (display "Invalid parameters passed to find-in-entity-list\n"))))
  
(define pick-coedge
  (lambda ()
    (let ((picked-face (pick-a-face))
          (picked-edge (pick-an-edge)))
      (if (entity? picked-face)
          (if (entity? picked-edge)
              (let ((loop (entity:coedges picked-face))
                    (coedges (entity:coedges picked-edge)))
                (match-entity loop coedges))
              (display "Edge not picked\n"))
          (display "Face not picked\n")))))
  
